home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
Modules
/
eubang.em
< prev
next >
Wrap
Lisp/Scheme
|
1992-10-06
|
15KB
|
592 lines
(defmodule eubang (standard0 plural) ()
(setq MasPar-X-Config 16)
(setq MasPar-Y-Config 32)
(defclass xec ()
((context
initarg context
reader cntext)
(offset
initarg offset
reader offset))
constructor (allocate-xec context offset)
predicate xecp)
(defun make-xec (c o)
(become-strange (allocate-xec c o)))
(defmethod generic-prin ((p xec) str)
(format str "#x(")
(mp-print (cntext p) (offset p) str)
(format str ")")
p)
(defmethod generic-write ((p xec) str)
(format str "#x(")
(mp-print (cntext p) (offset p) str)
(format str ")")
p)
(defclass paralation-internal ()
((context
initarg context
reader context-internal)
(size
initarg size
reader length-internal))
constructor (allocate-paralation context size)
predicate paralationp)
(defun make-paralation (size)
(let* ((height (+ (/ size MasPar-X-Config)
(if (zerop (remainder size MasPar-X-Config)) 0 1)))
(ctxt (mp-make-context (if (= height 1) size MasPar-X-Config)
height))
(ofst (mp-context ctxt))
(enum (mp-scan-op ctxt (mp-bang ctxt 1) 610)))
(mp-if ctxt (mp-rel-op ctxt enum (mp-bang ctxt size) 652))
(mp-else ctxt)
(mp-assign ctxt ofst (mp-bang ctxt '(() ())))
(mp-fi ctxt)
(allocate-paralation ctxt size)))
(defclass mp-object ()
((paralation
initarg paralation
reader paralation)
(offset
initarg offset
reader offset))
predicate mp-object-p)
(defun context (mp-o) (context-internal (paralation mp-o)))
(defclass plural (mp-object)
()
constructor (allocate-plural paralation offset)
predicate pluralp)
(defmethod generic-prin ((p plural) str)
(format str "#P(")
(mp-print (context p) (offset p) () () str)
(format str ")")
p)
(defmethod generic-write ((p plural) str)
(format str "#P(")
(mp-print (context p) (offset p) () () str)
(format str ")")
p)
(defun make-plural (n-or-plural)
(cond
((eq (class-of n-or-plural) integer)
(let ((new-paralation (make-paralation n-or-plural)))
(become-strange (allocate-plural new-paralation
(mp-make-plural (context-internal
new-paralation))))))
((pluralp n-or-plural)
(become-strange (allocate-plural (paralation n-or-plural)
(mp-make-plural (context
n-or-plural)))))
(t (error "Aaaeeii, wot dis in make-plural?" clock-tick))))
(defun plural-length (object)
(if (pluralp object) (length-internal (paralation object))
(error "Arg1 not a plural" clock-tick)))
(defun plural-ref (plural index)
(cond
((not (pluralp plural)) (error "Arg1 not a plural" clock-tick))
((not (eq (class-of index) integer))
(error "Arg2 not an integer" clock-tick))
(t (mp-ref (context plural) (offset plural) index))))
((setter setter) plural-ref
(lambda (plural index value)
(cond
((not (pluralp plural)) (error "Arg1 not a plural" clock-tick))
((not (eq (class-of index) integer))
(error "Arg2 not an integer" clock-tick))
(t (mp-set (context plural) (offset plural) index value)))
plural))
(defun if-s-internal (bool consc antec)
(let ((result (make-plural bool)))
(if (mp-if (context bool) (offset bool))
(let ((consc-result (consc)))
(if (pluralp consc-result)
(mp-assign (context result) (offset result)
(offset consc-result))
())) ())
(if (mp-else (context bool))
(let ((antec-result (antec)))
(if (pluralp antec-result)
(mp-assign (context result) (offset result)
(offset antec-result))
())) ())
(mp-fi (context bool))
result))
(defmacro if-s (bool consc antec)
`(if-s-internal ,bool (lambda () ,consc) (lambda () ,antec)))
(defun list-to-plural (list . plurals)
(if (or (null plurals) (pluralp (car plurals)))
(let ((new (if (null plurals) (make-plural (list-length list))
(make-plural (car plurals)))))
(labels ((recurse (index list)
(mp-set (context new) (offset new) index (car list))
(if (or (zerop index) (null (cdr list))) new
(recurse (- index 1) (cdr list)))))
(recurse (- (list-length list) 1) (reverse list))))
(error "Arg2 not a plural" clock-tick)))
(defun conformantp (arg1 arg2)
(cond
((not (pluralp arg1)) ())
((not (pluralp arg2)) ())
(t (eq (context arg1) (context arg2)))))
(defun bang (object plural)
(if (pluralp plural)
(allocate-plural (paralation plural) (mp-bang (context plural) object))
(error "Arg2 not a plural" clock-tick)))
(defun auto-bang (arg1 arg2 fn)
(cond
((not (or (pluralp arg1) (pluralp arg2)))
(error "Neither argument is a plural" clock-tick))
((and (pluralp arg1) (pluralp arg2) (conformantp arg1 arg2))
(allocate-plural (paralation arg1)
(fn (context arg1) (offset arg1) (offset arg2))))
(t (allocate-plural (paralation (if (pluralp arg1) arg1 arg2))
(if (pluralp arg1)
(fn (context arg1) (offset arg1)
(mp-bang (context arg1) arg2))
(fn (context arg2) (mp-bang (context arg2) arg1)
(offset arg2)))))))
(defun abs-s (arg)
(if (pluralp arg)
(allocate-plural (paralation arg)
(mp-un-op (context arg) (offset arg) 621))
(error "Arg1 not a plural" clock-tick)))
(defun negate-s (arg)
(if (pluralp arg)
(allocate-plural (paralation arg)
(mp-un-op (context arg) (offset arg) 620))
(error "Arg1 not a plural" clock-tick)))
(defun delta-s (arg)
(if (pluralp arg)
(allocate-plural (paralation arg)
(mp-un-op (context arg) (offset arg) 670))
(error "Arg1 not a plural" clock-tick)))
(defun sigma-s (arg)
(if (pluralp arg)
(allocate-plural (paralation arg)
(mp-un-op (context arg) (offset arg) 671))
(error "Arg1 not a plural" clock-tick)))
(defun eq-s (arg1 arg2)
(if (conformantp arg1 arg2)
(allocate-plural (paralation arg1)
(mp-eq (context arg1) (offset arg1) (offset arg2)))
(error "Incompatible arguments" clock-tick)))
(defun cons-s (arg1 arg2)
(auto-bang arg1 arg2 mp-cons))
(defun car-s (object)
(if (pluralp object)
(allocate-plural (paralation object)
(mp-car (context object) (offset object)))
(error "Arg1 is not a plural" clock-tick)))
(defun cdr-s (object)
(if (pluralp object)
(allocate-plural (paralation object)
(mp-cdr (context object) (offset object)))
(error "Arg1 is not a plural" clock-tick)))
((setter setter) car-s
(lambda (plural value)
(if (not (pluralp plural)) (error "Arg1 not a plural" clock-tick)
(auto-bang plural value mp-rplac-a))))
((setter setter) cdr-s
(lambda (plural value)
(if (not (pluralp plural)) (error "Arg1 not a plural" clock-tick)
(auto-bang plural value mp-rplac-d))))
(defun make-vector-s (length)
(if (pluralp length)
(allocate-plural (paralation length)
(mp-make-vector (context length) (offset length)))
(error "Arg1 not a plural" clock-tick)))
(defun vector-length-s (vector)
(if (pluralp vector)
(allocate-plural (paralation vector)
(mp-vector-length (context vector) (offset vector)))
(error "Arg1 not a plural" clock-tick)))
(defun vector-ref-s (vector index)
(if (not (pluralp vector)) (error "Arg1 not a plural" clock-tick)
(auto-bang vector index mp-vector-ref)))
((setter setter) vector-ref-s
(lambda (vector index value)
(if (not (pluralp vector)) (error "Arg1 not a plural" clock-tick)
(let ((tmp-index (if (pluralp index) index (bang index vector)))
(tmp-value (if (pluralp value) value (bang value vector))))
(if (and (eq (context vector) (context tmp-index))
(eq (context vector) (context tmp-value)))
(progn
(mp-vector-set (context vector) (offset vector)
(offset tmp-index) (offset tmp-value))
vector)
(error "Non-conformant arguments" clock-tick))))))
(defun consp-s (object)
(if (pluralp object)
(allocate-plural (paralation object)
(mp-test (context object) (offset object) 2))
(error "Arg1 not a plural" clock-tick)))
; (defun nullp-s (object)
; (if (pluralp object)
; (allocate-plural (paralation object)
; (mp-test (context object) (offset object) #x7fff))
; (error "Arg1 not a plural" clock-tick)))
;
; The old hack method doesn't work as nil is now a genuine object on
; each PE - not just a fancy address
(defun nullp-s (object)
(if (pluralp object)
(allocate-plural (paralation object)
(mp-eq (context object) (offset object)
(mp-bang (context object) ())))
(error "Arg1 not a plural" clock-tick)))
(defun intp-s (object)
(if (pluralp object)
(allocate-plural (paralation object)
(mp-test (context object) (offset object) 1))
(error "Arg1 not a plural" clock-tick)))
(defun floatp-s (object)
(if (pluralp object)
(allocate-plural (paralation object)
(mp-test (context object) (offset object) 4))
(error "Arg1 not a plural" clock-tick)))
(defun vectorp-s (object)
(if (pluralp object)
(allocate-plural (paralation object)
(mp-test (context object) (offset object) 3))
(error "Arg1 not a plural" clock-tick)))
(defun scan (p op)
(allocate-plural (paralation p)
(mp-scan-op (context p) (offset p)
(cond
((eq op +) 610)
((eq op *) 613)
((eq op max) 660)
(t 661)))))
(defun reduce (p op)
(mp-ref (paralation p)
(mp-scan-op (context p) (offset p)
(cond
((eq op +) 610)
((eq op *) 613)
((equal op 'max) MP_MAX)
(t 661))) (- (field-length p) 1)))
(defmethod binary-plus ((p1 plural) (p2 plural))
(if (conformantp p1 p2)
(allocate-plural
(paralation p1) (mp-bin-op (context p1) (offset p1) (offset p2) 610))
(error "Non-conformant arguments" clock-tick)))
(defmethod binary-difference ((p1 plural) (p2 plural))
(if (conformantp p1 p2)
(allocate-plural
(paralation p1) (mp-bin-op (context p1)
(offset p1) (offset p2) 611))
(error "Non-conformant arguments" clock-tick)))
(defmethod binary-times ((p1 plural) (p2 plural))
(if (conformantp p1 p2)
(allocate-plural
(paralation p1) (mp-bin-op (context p1)
(offset p1) (offset p2) 613))
(error "Non-conformant arguments" clock-tick)))
(defmethod binary-divide ((p1 plural) (p2 plural))
(if (conformantp p1 p2)
(allocate-plural
(paralation p1) (mp-bin-op (context p1)
(offset p1) (offset p2) 612))
(error "Non-conformant arguments" clock-tick)))
(defmethod binary-gt ((p1 plural) (p2 plural))
(if (conformantp p1 p2)
(allocate-plural
(paralation p1) (mp-rel-op (context p1)
(offset p1) (offset p2) 651))
(error "Non-conformant arguments" clock-tick)))
(defmethod binary-lt ((p1 plural) (p2 plural))
(if (conformantp p1 p2)
(allocate-plural
(paralation p1) (mp-rel-op (context p1)
(offset p1) (offset p2) 650))
(error "Non-conformant arguments" clock-tick)))
(defun remainder-s (arg1 arg2)
(cond
((not (pluralp arg1)) (error "Arg1 not a plural" clock-tick))
((not (pluralp arg2)) (error "Arg2 not a plural" clock-tick))
((not (conformantp arg1 arg2))
(error "Non-conformant arguments" clock-tick))
(t (allocate-plural (paralation arg1)
(mp-bin-op (context arg1) (offset arg1)
(offset arg2) 614)))))
(defun and-s (arg1 arg2)
(auto-bang arg1 arg2 mp-and))
(defun or-s (arg1 arg2)
(auto-bang arg1 arg2 mp-or))
(defclass mapping (mp-object)
()
constructor (allocate-mapping paralation offset)
predicate mappingp)
(defun match (to from)
(if (and (pluralp from) (pluralp to))
(allocate-mapping (paralation to) (mp-match (context to) (offset to)
(context from) (offset from)))
(error "Both args should be plurals" clock-tick)))
(defun move (data map with default)
(cond
((not (pluralp data)) (error "Arg1 msut be a plural" clock-tick))
((not (mappingp map)) (error "Arg2 must be a mapping" clock-tick))
(t (let ((moved (allocate-plural (paralation map)
(mp-move (context data) (offset data)
(context map) (offset map)))))
(labels ((recurse (list-s cdr-list-s)
(if-s-internal cdr-list-s
(lambda () (with (car-s list-s)
(recurse cdr-list-s (cdr-s cdr-list-s))))
(lambda () (car-s list-s)))))
(if-s-internal moved (lambda () (recurse moved (cdr-s moved)))
(lambda () (bang default moved))))))))
; Modification to mp-move - plural for result has to be preallocated
(defun move (data map with default)
(cond
((not (pluralp data)) (error "Arg1 msut be a plural" clock-tick))
((not (mappingp map)) (error "Arg2 must be a mapping" clock-tick))
(t (let ((moved (allocate-plural (paralation map)
(mp-make-plural (context map)))))
(mp-move (context data) (offset data)
(context map) (offset map) (offset moved))
(labels ((recurse (list-s cdr-list-s)
(if-s-internal cdr-list-s
(lambda () (with (car-s list-s)
(recurse cdr-list-s (cdr-s cdr-list-s))))
(lambda () (car-s list-s)))))
(if-s-internal moved (lambda () (recurse moved (cdr-s moved)))
(lambda () (bang default moved))))))))
(defun ll-move (data map)
(cond
((not (pluralp data)) (error "Arg1 must be a plural" clock-tick))
((not (mapping map)) (error "Arg2 must be a mapping" clock-tick))
(t (allocate-plurak (paralation map)
(mp-move (context data) (offset data)
(context map) (ofset map))))))
(defun look-at-mapping (map)
(if (mappingp map)
(allocate-plural (paralation map) (offset map))
(error "Arg1 should be a map" clock-tick)))
(defun visualise (p)
(if (pluralp p) (progn
(mp-x-stat (context p) (offset p))
p)
(error "Arg1 not a plural")))
(export match move make-plural plural-length bang plural-ref
list-to-plural eq-s if-s if-s-internal cons-s car-s cdr-s
and-s or-s visualise
abs-s negate-s sigma-s delta-s
make-vector-s vector-length-s vector-ref-s
consp-s nullp-s intp-s floatp-s vectorp-s
ll-move mp-gc)
)
; This function probably needs adding, this is its hacked from CM-Lisp
; form
; (defun put (x at in)
; (cond
; ((not (xecp in)) (error "Destination (arg 2) is not a xec" clock-tick))
; ((not (conformantp x at))
; (error "Values and indexes not conformant" clock-tick))
; (t (let ((ctxt-x (context x))
; (ofst-at (offset at))
; (ctxt-in (context in)))
; (allocate-xec
; ctxt-in
; (cm-put ctxt-x (offset x)
; (mp-bin-op ctxt-x ofst-at
; (mp-bin-op ctxt-x ofst-at
; (mp-bang ctxt-x (cm-start in))))))))))